home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / CALENDAR / MWCAL10 / MWCALEND.PAS < prev   
Pascal/Delphi Source File  |  1996-11-08  |  14KB  |  468 lines
  1. unit MWCalendar;
  2.  
  3. interface
  4.  
  5. uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics,
  6.      ExtCtrls;
  7.  
  8. type
  9.   DayStr = String[2];
  10.  
  11.   TMWCalendarBevel = (bvLowered, bvRaised);
  12.   TMWCalendarBorderStyle = (bsNone, bsSingle);
  13.  
  14.   TMWCalendar = class(TGraphicControl)
  15.     FDaysThisMonth: Integer;
  16.     FDisplayBoxes: Boolean;
  17.     FActive: Boolean;
  18.     FOnChange: TNotifyEvent;
  19.     FCalendarDate: TDateTime;
  20.     FDay: Word;
  21.     FMonth: Word;
  22.     FYear: Word;
  23.     FDayOffset: Integer;
  24.     FMonthOffset: Integer;
  25.     FSaturdayFontColor: TColor;
  26.     FSundayFontColor: TColor;
  27.     FFontColor: TColor;
  28.     FBkColor: TColor;
  29.     FLightColor: TColor;
  30.     FDarkColor: TColor;
  31.     FBorderStyle: TMWCalendarBorderStyle;
  32.     FBevel: TMWCalendarBevel;
  33.     FCtl3D: Boolean;
  34.     FFocusControl: TWinControl;
  35.   private
  36.     procedure DoDrawText(var Rect: TRect; Flags: Word);
  37.     function GetTransparent: Boolean;
  38.     procedure SetCalendarDate(Value: TDateTime);
  39.     procedure SetFocusControl(Value: TWinControl);
  40.     procedure SetTransparent(Value: Boolean);
  41.     procedure SetCtl3D(Value: Boolean);
  42.     procedure SetBorderStyle(Value: TMWCalendarBorderStyle);
  43.     procedure SetBevel(Value: TMWCalendarBevel);
  44.     procedure SetBkColor(Value: TColor);
  45.     procedure SetLightColor(Value: TColor);
  46.     procedure SetDarkColor(Value: TColor);
  47.     procedure SetSaturdayColor(Value: TColor);
  48.     procedure SetSundayColor(Value: TColor);
  49.     procedure SetFontColor(Value: TColor);
  50.     procedure SetDayOffset(Value: Integer);
  51.     procedure ChangeMonth(Delta: Integer);
  52.     procedure SetActive(Value: Boolean);
  53.     procedure SetDisplayBoxes(Value: Boolean);
  54.   protected
  55.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  56.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  57.     function DaysThisMonth: Integer; virtual;
  58.     procedure Notification(AComponent: TComponent;
  59.       Operation: TOperation); override;
  60.     procedure Paint; override;
  61.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  62.     property Width;
  63.     property Height;
  64.     property Font;
  65.   public
  66.     constructor Create(AOwner: TComponent); override;
  67.     property Canvas;
  68.     property CalendarDate: TDateTime read FCalendarDate write SetCalendarDate;
  69.   published
  70.     property DisplayBoxes: Boolean read FDisplayBoxes write SetDisplayBoxes default True;
  71.     property Active: Boolean read FActive write SetActive default True;
  72.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  73.     property DayOffset: Integer read FDayOffset write SetDayOffset default 1;
  74.     property Color;
  75.     property SaturdayColor: TColor read FSaturdayFontColor write SetSaturdayColor default clBlack;
  76.     property SundayColor: TColor read FSundayFontColor write SetSundayColor default clBlack;
  77.     property FontColor: TColor read FFontColor write SetFontColor default clBlack;
  78.     property Enabled;
  79.     property Transparent: Boolean read GetTransparent write SetTransparent default False;
  80.     property Visible;
  81.     property Ctl3D: Boolean read FCtl3D write SetCtl3D default False;
  82.     property BorderStyle: TMWCalendarBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  83.     property BevelStyle: TMWCalendarBevel read FBevel write SetBevel default bvRaised;
  84.     property BkColor: TColor read FBkColor write SetBkColor default clBtnFace;
  85.     property LightColor: TColor read FLightColor write SetLightColor default clBtnHighlight;
  86.     property DarkColor: TColor read FDarkColor write SetDarkColor default clBtnShadow;
  87.   end;
  88.  
  89. procedure Register;
  90.  
  91. implementation
  92.  
  93. var
  94.   DayTable: array[0..6, 0..5] of Byte;
  95.  
  96. { TMWCalendar }
  97.  
  98. constructor TMWCalendar.Create(AOwner: TComponent);
  99. begin
  100.   inherited Create(AOwner);
  101.   ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  102.   FDisplayBoxes := True;
  103.   FActive := True;
  104.   FSaturdayFontColor := clBlack;
  105.   FSundayFontColor := clBlack;
  106.   FFontColor := clBlack;
  107.   FBkColor := clBtnFace;
  108.   FLightColor := clBtnHighlight;
  109.   FDarkColor := clBtnShadow;
  110.   Width := 144;
  111.   Height := 148;
  112.   FDayOffset := 1;
  113.   FCtl3D := False;
  114.   FBorderStyle := bsNone;
  115.   FBevel := bvRaised;
  116.   CalendarDate := Now;
  117.   SetBounds(Left, Top, Width, Height);
  118. end;
  119.  
  120. procedure TMWCalendar.DoDrawText(var Rect: TRect; Flags: Word);
  121. var
  122.   Text: string;
  123. begin
  124.   Text := LongMonthNames[FMonth]+' '+IntToStr(FYear);
  125.   if Text[1] in ['a'..'z'] then Text[1] := Char(Ord(Text[1])-32);
  126.   Flags := Flags or DT_NOPREFIX;
  127.   Canvas.Font := Font;
  128.   DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  129. end;
  130.  
  131. procedure TMWCalendar.Paint;
  132. var
  133.   TheRect: TRect;
  134.   RectPlus: TRect;
  135.   TopColor: TColor;
  136.   BottomColor: TColor;
  137.   PenColor: TColor;
  138.   i, j: Integer;
  139.   DayText: DayStr;
  140. begin
  141.   with Canvas do
  142.     begin
  143.     Font.Name := 'MS Sans Serif';
  144.     Font.Size := 8;
  145.     Font.Color := FFontColor;
  146.     if not Transparent then
  147.       begin
  148.       Brush.Color := Self.Color;
  149.       Brush.Style := bsSolid;
  150.       FillRect(ClientRect);
  151.       end;
  152.     Brush.Style := bsClear;
  153.     TheRect := ClientRect;
  154.     if FBorderStyle <> bsNone then
  155.       begin
  156.       if FCtl3D then
  157.         begin
  158.         TopColor := clBtnShadow;
  159.         BottomColor := clBtnHighlight;
  160.         Frame3D(Canvas, TheRect, TopColor, BottomColor, 1);
  161.         end
  162.       else
  163.         begin
  164.         PenColor := Pen.Color;
  165.         Pen.Color := clWindowFrame;
  166.         Rectangle(TheRect.Left, TheRect.Top, TheRect.Right, TheRect.Bottom);
  167.         Pen.Color := PenColor;
  168.         end;
  169.       InflateRect(TheRect, -1, -1);
  170.       end;
  171.     TopColor := FLightColor;
  172.     if FBevel = bvLowered then TopColor := FDarkColor;
  173.     BottomColor := FDarkColor;
  174.     if FBevel = bvLowered then BottomColor := FLightColor;
  175.     if FActive then
  176.       begin
  177.       RectPlus := Rect(TheRect.Left, TheRect.Top, TheRect.Left+17, TheRect.Top+17);
  178.       Frame3D(Canvas, RectPlus, FLightColor, FDarkColor, 1);
  179.       RectPlus := Rect(TheRect.Right-17, TheRect.Top, TheRect.Right, TheRect.Top+17);
  180.       Frame3D(Canvas, RectPlus, FLightColor, FDarkColor, 1);
  181.       RectPlus := Rect(18, TheRect.Top, TheRect.Right-17, TheRect.Top+17);
  182.       Pen.Color := FLightColor;
  183.       MoveTo(5, 8);
  184.       LineTo(11, 2);
  185.       Pen.Color := FDarkColor;
  186.       LineTo(11, 14);
  187.       LineTo(5, 8);
  188.       MoveTo(TheRect.Right-11, 2);
  189.       LineTo(TheRect.Right-5, 8);
  190.       LineTo(TheRect.Right-11, 14);
  191.       Pen.Color := FLightColor;
  192.       LineTo(TheRect.Right-11, 2);
  193.       end
  194.     else
  195.       RectPlus := Rect(TheRect.Left, TheRect.Top, TheRect.Right, TheRect.Top+17);
  196.     Frame3D(Canvas, RectPlus, FLightColor, FDarkColor, 1);
  197.     DoDrawText(RectPlus, (DT_EXPANDTABS or DT_WORDBREAK or DT_CENTER));
  198.     RectPlus := TheRect;
  199.     RectPlus.Top := TheRect.Top + 17;
  200.     Frame3D(Canvas, RectPlus, TopColor, BottomColor, 1);
  201.     SetTextAlign(Handle, TA_CENTER);
  202.     for i := 0 to 6 do
  203.       begin
  204.       case (i+FDayOffset) mod 7 of
  205.         0  : Font.Color := FSundayFontColor;
  206.         6  : Font.Color := FSaturdayFontColor;
  207.         else Font.Color := FFontColor;
  208.         end;
  209.       RectPlus := Rect(TheRect.Left + 2 + i*20, TheRect.Top + 20, TheRect.Left + 22 + i*20, TheRect.Top + 38);
  210.       DayText := ShortDayNames[(FDayOffset + i) mod 7 + 1];
  211.       if DayText = 'N.' then DayText := 'N';
  212.       TextOut(TheRect.Left + 11 + i*20, TheRect.Top + 22, DayText);
  213.       end;
  214.     for j := 1 to 6 do
  215.       for i := 0 to 6 do
  216.         if DayTable[i,j-1] <> 0 then
  217.           begin
  218.           case (i+FDayOffset) mod 7 of
  219.             0  : Font.Color := FSundayFontColor;
  220.             6  : Font.Color := FSaturdayFontColor;
  221.             else Font.Color := FFontColor;
  222.             end;
  223.           RectPlus := Rect(TheRect.Left + 2 + i*20, TheRect.Top + 20 + j*18, TheRect.Left + 22 + i*20, TheRect.Top + 38 + j*18);
  224.           if (DayTable[i,j-1] = FDay) and FActive then
  225.             begin
  226.             if FDisplayBoxes then
  227.               Frame3D(Canvas, RectPlus, TopColor, BottomColor, 1)
  228.             else
  229.               Frame3D(Canvas, RectPlus, BottomColor, TopColor, 1);
  230.             Brush.Color := FBkColor;
  231.             end
  232.           else
  233.             begin
  234.             if FDisplayBoxes then Frame3D(Canvas, RectPlus, BottomColor, TopColor, 1);
  235.             Brush.Style := bsClear;
  236.             end;
  237.           DayText := IntToStr(DayTable[i,j-1]);
  238.           TextRect(RectPlus, TheRect.Left + 12 + i*20, TheRect.Top + 22 + j*18, DayText);
  239.           end;
  240.     SetTextAlign(Handle, TA_LEFT);
  241.     end;
  242. end;
  243.  
  244. function TMWCalendar.GetTransparent: Boolean;
  245. begin
  246.   Result := not (csOpaque in ControlStyle);
  247. end;
  248.  
  249. procedure TMWCalendar.SetCalendarDate(Value: TDateTime);
  250. var
  251.   i,j,k: Integer;
  252.   TmpDate: TDateTime;
  253. begin
  254.   FCalendarDate := Value;
  255.   DecodeDate(CalendarDate, FYear, FMonth, FDay);
  256.   TmpDate := EncodeDate(FYear, FMonth, 1);
  257.   FMonthOffset := DayOfWeek(TmpDate)-1;
  258.   k := -((7-DayOffset+FMonthOffset) mod 7);
  259.   for j := 0 to 5 do
  260.     for i := 0 to 6 do
  261.       begin
  262.       Inc(k);
  263.       if (k < 0) or (k > DaysThisMonth) then
  264.         DayTable[i, j] := 0
  265.       else
  266.         DayTable[i, j] := k;
  267.       end;
  268.   Invalidate;
  269.   if Assigned(FOnChange) then FOnChange(Self);
  270. end;
  271.  
  272. procedure TMWCalendar.SetFocusControl(Value: TWinControl);
  273. begin
  274.   FFocusControl := Value;
  275.   if Value <> nil then Value.FreeNotification(Self);
  276. end;
  277.  
  278. procedure TMWCalendar.SetTransparent(Value: Boolean);
  279. begin
  280.   if Transparent <> Value then
  281.   begin
  282.     if Value then
  283.       ControlStyle := ControlStyle - [csOpaque] else
  284.       ControlStyle := ControlStyle + [csOpaque];
  285.     Invalidate;
  286.   end;
  287. end;
  288.  
  289. procedure TMWCalendar.SetBkColor(Value: TColor);
  290. begin
  291.   FBkColor := Value;
  292.   Invalidate;
  293. end;
  294.  
  295. procedure TMWCalendar.SetLightColor(Value: TColor);
  296. begin
  297.   FLightColor := Value;
  298.   Invalidate;
  299. end;
  300.  
  301. procedure TMWCalendar.SetDarkColor(Value: TColor);
  302. begin
  303.   FDarkColor := Value;
  304.   Invalidate;
  305. end;
  306.  
  307. procedure TMWCalendar.SetDayOffset(Value: Integer);
  308. begin
  309.   if (Value >=0) and (Value < 7) then
  310.     begin
  311.     FDayOffset := Value;
  312.     SetCalendarDate(CalendarDate);
  313.     end;
  314. end;
  315.  
  316. procedure TMWCalendar.SetSaturdayColor(Value: TColor);
  317. begin
  318.   FSaturdayFontColor := Value;
  319.   Invalidate;
  320. end;
  321.  
  322. procedure TMWCalendar.SetSundayColor(Value: TColor);
  323. begin
  324.   FSundayFontColor := Value;
  325.   Invalidate;
  326. end;
  327.  
  328. procedure TMWCalendar.SetFontColor(Value: TColor);
  329. begin
  330.   FFontColor := Value;
  331.   Invalidate;
  332. end;
  333.  
  334. function TMWCalendar.IsLeapYear(AYear: Integer): Boolean;
  335. begin
  336.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  337. end;
  338.  
  339. function TMWCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  340. const
  341.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  342. begin
  343.   Result := DaysInMonth[AMonth];
  344.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  345. end;
  346.  
  347. function TMWCalendar.DaysThisMonth: Integer;
  348. begin
  349.   FDaysThisMonth := DaysPerMonth(FYear, FMonth);
  350.   Result := FDaysThisMonth;
  351. end;
  352.  
  353. procedure TMWCalendar.Notification(AComponent: TComponent;
  354.   Operation: TOperation);
  355. begin
  356.   inherited Notification(AComponent, Operation);
  357.   if (Operation = opRemove) and (AComponent = FFocusControl) then
  358.     FFocusControl := nil;
  359. end;
  360.  
  361. procedure TMWCalendar.SetCtl3D(Value: Boolean);
  362. begin
  363.   if FCtl3D <> Value then
  364.   begin
  365.     FCtl3D := Value;
  366.     Invalidate;
  367.   end;
  368. end;
  369.  
  370. procedure TMWCalendar.SetBorderStyle(Value: TMWCalendarBorderStyle);
  371. begin
  372.   if FBorderStyle <> Value then
  373.   begin
  374.     FBorderStyle := Value;
  375.     if FBorderStyle = bsNone then
  376.       begin Width := 144; Height := 148; end
  377.     else
  378.       begin Width := 146; Height := 150; end;
  379.     SetBounds(Left, Top, Width, Height);
  380.     Invalidate;
  381.   end;
  382. end;
  383.  
  384. procedure TMWCalendar.SetBevel(Value: TMWCalendarBevel);
  385. begin
  386.   if FBevel <> Value then
  387.   begin
  388.     FBevel := Value;
  389.     SetBounds(Left, Top, Width, Height);
  390.     Invalidate;
  391.   end;
  392. end;
  393.  
  394. procedure TMWCalendar.WMLButtonDown(var Message: TWMLButtonDown);
  395. var
  396.   TheRect: TRect;
  397.   RectPlus: TRect;
  398.   i, j: Integer;
  399. begin
  400.   SendCancelMode(Self);
  401.   inherited;
  402.   if FActive then
  403.     begin
  404.     TheRect := GetClientRect;
  405.     with Message do
  406.       begin
  407.       if (XPos>0) and (XPos<18) and (YPos>0) and (YPos<18) then
  408.         with Canvas do
  409.           begin
  410.           RectPlus := Rect(TheRect.Right-17, TheRect.Top, TheRect.Right, TheRect.Top+17);
  411.           Frame3D(Canvas, RectPlus, FDarkColor, FLightColor, 1);
  412.           ChangeMonth(-1);
  413.           end;
  414.       if (XPos>TheRect.Right-17) and (XPos<TheRect.Right) and (YPos>0) and (YPos<18) then
  415.         with Canvas do
  416.           begin
  417.           RectPlus := Rect(TheRect.Right-17, TheRect.Top, TheRect.Right, TheRect.Top+17);
  418.           Frame3D(Canvas, RectPlus, FDarkColor, FLightColor, 1);
  419.           ChangeMonth(1);
  420.           end;
  421.       if (XPos>2) and (XPos<TheRect.Right-2) and (YPos>37) then
  422.         begin
  423.         i := (XPos-2) div 20;
  424.         j := (YPos-38) div 18;
  425.         if DayTable[i,j] <> 0 then
  426.           CalendarDate := EncodeDate(FYear, FMonth, DayTable[i,j]);
  427.         end;
  428.       end;
  429.     end;
  430. end;
  431.  
  432. procedure TMWCalendar.ChangeMonth(Delta: Integer);
  433. var
  434.   AYear, AMonth, ADay: Word;
  435.   NewDate: TDateTime;
  436.   CurDay: Integer;
  437. begin
  438.   DecodeDate(FCalendarDate, AYear, AMonth, ADay);
  439.   CurDay := ADay;
  440.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  441.   else ADay := 1;
  442.   NewDate := EncodeDate(AYear, AMonth, ADay);
  443.   NewDate := NewDate + Delta;
  444.   DecodeDate(NewDate, AYear, AMonth, ADay);
  445.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  446.   else ADay := DaysPerMonth(AYear, AMonth);
  447.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  448. end;
  449.  
  450. procedure TMWCalendar.SetActive(Value: Boolean);
  451. begin
  452.   FActive := Value;
  453.   Invalidate;
  454. end;
  455.  
  456. procedure TMWCalendar.SetDisplayBoxes(Value: Boolean);
  457. begin
  458.   FDisplayBoxes := Value;
  459.   Invalidate;
  460. end;
  461.  
  462. procedure Register;
  463. begin
  464.   RegisterComponents('MWCtrl', [TMWCalendar]);
  465. end;
  466.  
  467. end.
  468.